Cream of the Crop 21/Cream of the Crop 21 (Terry Blount) (October 1996).iso/os2/e33el2.zip/emacs/19.33/lisp/cal-islam.el

Lisp/Scheme | 1996-03-22 | 23KB | 493 lines

;;; cal-islam.el --- calendar functions for the Islamic calendar.

;; Copyright (C) 1995 Free Software Foundation, Inc.

;; Author: Edward M. Reingold <[e-mail]>
;; Keywords: calendar
;; Human-Keywords: Islamic calendar, calendar, diary

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; This collection of functions implements the features of calendar.el and
;; diary.el that deal with the Islamic calendar.

;; Comments, corrections, and improvements should be sent to
;;  Edward M. Reingold               Department of Computer Science
;;  [phone]                   University of Illinois at Urbana-Champaign
;;  [e-mail]             1304 West Springfield Avenue
;;                                   Urbana, Illinois 61801

;;; Code:

(require 'cal-julian)

(defvar calendar-islamic-month-name-array
  ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II"
   "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"])

(defvar calendar-islamic-epoch (calendar-absolute-from-julian '(7 16 622))
  "Absolute date of start of Islamic calendar = August 29, 284 A.D. (Julian).")

(defun islamic-calendar-leap-year-p (year)
  "Returns t if YEAR is a leap year on the Islamic calendar."
  (memq (% year 30)
        (list 2 5 7 10 13 16 18 21 24 26 29)))

(defun islamic-calendar-last-day-of-month (month year)
  "The last day in MONTH during YEAR on the Islamic calendar."
  (cond
   ((memq month (list 1 3 5 7 9 11)) 30)
   ((memq month (list 2 4 6 8 10)) 29)
   (t (if (islamic-calendar-leap-year-p year) 30 29))))

(defun islamic-calendar-day-number (date)
  "Return the day number within the year of the Islamic date DATE."
    (let* ((month (extract-calendar-month date))
           (day (extract-calendar-day date)))
      (+ (* 30 (/ month 2))
         (* 29 (/ (1- month) 2))
         day)))

(defun calendar-absolute-from-islamic (date)
  "Absolute date of Islamic DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
  (let* ((month (extract-calendar-month date))
         (day (extract-calendar-day date))
         (year (extract-calendar-year date))
         (y (% year 30))
         (leap-years-in-cycle
          (cond
           ((< y 3) 0)  ((< y 6) 1)  ((< y 8) 2)  ((< y 11) 3) ((< y 14) 4)
           ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9)
           (t 10))))
    (+ (islamic-calendar-day-number date);; days so far this year
       (* (1- year) 354)                 ;; days in all non-leap years
       (* 11 (/ year 30))                ;; leap days in complete cycles
       leap-years-in-cycle               ;; leap days this cycle
       (1- calendar-islamic-epoch))))    ;; days before start of calendar

(defun calendar-islamic-from-absolute (date)
  "Compute the Islamic date (month day year) corresponding to absolute DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
  (if (< date calendar-islamic-epoch)
      (list 0 0 0);; pre-Islamic date
    (let* ((approx (/ (- date calendar-islamic-epoch)
                      355));; Approximation from below.
           (year           ;; Search forward from the approximation.
            (+ approx
               (calendar-sum y approx
                             (>= date (calendar-absolute-from-islamic
                                       (list 1 1 (1+ y))))
                             1)))
           (month          ;; Search forward from Muharram.
            (1+ (calendar-sum m 1
                              (> date
                                 (calendar-absolute-from-islamic
                                  (list m
                                        (islamic-calendar-last-day-of-month
                                         m year)
                                        year)))
                              1)))
           (day            ;; Calculate the day by subtraction.
            (- date
               (1- (calendar-absolute-from-islamic (list month 1 year))))))
      (list month day year))))

(defun calendar-islamic-date-string (&optional date)
  "String of Islamic date before sunset of Gregorian DATE.
Returns the empty string if DATE is pre-Islamic.
Defaults to today's date if DATE is not given.
Driven by the variable `calendar-date-display-form'."
  (let ((calendar-month-name-array calendar-islamic-month-name-array)
        (islamic-date (calendar-islamic-from-absolute
                       (calendar-absolute-from-gregorian
                        (or date (calendar-current-date))))))
    (if (< (extract-calendar-year islamic-date) 1)
        ""
      (calendar-date-string islamic-date nil t))))

(defun calendar-print-islamic-date ()
  "Show the Islamic calendar equivalent of the date under the cursor."
  (interactive)
  (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
    (if (string-equal i "")
        (message "Date is pre-Islamic")
      (message "Islamic date (until sunset): %s" i))))

(defun calendar-goto-islamic-date (date &optional noecho)
  "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t."
  (interactive
   (let* ((today (calendar-current-date))
          (year (calendar-read
                 "Islamic calendar year (>0): "
                 '(lambda (x) (> x 0))
                 (int-to-string
                  (extract-calendar-year
                   (calendar-islamic-from-absolute
                    (calendar-absolute-from-gregorian today))))))
          (month-array calendar-islamic-month-name-array)
          (completion-ignore-case t)
          (month (cdr (assoc
                       (capitalize
                        (completing-read
                         "Islamic calendar month name: "
                         (mapcar 'list (append month-array nil))
                         nil t))
                       (calendar-make-alist month-array 1 'capitalize))))
          (last (islamic-calendar-last-day-of-month month year))
          (day (calendar-read
                (format "Islamic calendar day (1-%d): " last)
                '(lambda (x) (and (< 0 x) (<= x last))))))
     (list (list month day year))))
  (calendar-goto-date (calendar-gregorian-from-absolute
                       (calendar-absolute-from-islamic date)))
  (or noecho (calendar-print-islamic-date)))

(defun diary-islamic-date ()
  "Islamic calendar equivalent of date diary entry."
  (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
    (if (string-equal i "")
        "Date is pre-Islamic"
      (format "Islamic date (until sunset): %s" i))))

(defun holiday-islamic (month day string)
  "Holiday on MONTH, DAY (Islamic) called STRING.
If MONTH, DAY (Islamic) is visible, the value returned is corresponding
Gregorian date in the form of the list (((month day year) STRING)).  Returns
nil if it is not visible in the current calendar window."
  (let* ((islamic-date (calendar-islamic-from-absolute
                        (calendar-absolute-from-gregorian
                         (list displayed-month 15 displayed-year))))
         (m (extract-calendar-month islamic-date))
         (y (extract-calendar-year islamic-date))
        (date))
    (if (< m 1)
        n